home *** CD-ROM | disk | FTP | other *** search
/ TeX 1995 July / TeX CD-ROM July 1995 (Disc 1)(Walnut Creek)(1995).ISO / macros / latex209 / contrib / textyl / psrc / textyl.pas.ag < prev    next >
Text File  |  1993-11-07  |  28KB  |  1,001 lines
  1. procedure tylBrokenLine (x0, y0, x1, y1, fontindex : integer;
  2.              line_type: LineStyle);
  3. label 10;
  4. var useXaxis: boolean;
  5.     a0, b0, a1, b1: integer;
  6.     a2, a3, b2, b3, K, gap, dot, dash: integer; 
  7.     s, z, fit: real;
  8.     J, frame, T: integer;
  9.     Dotgap, Dotdot:  integer;
  10.     Dashgap, Dashdash: integer;
  11.     DDotgap, DDotdot, DDotdash: integer;    
  12.     a1ma0 : integer;
  13.     
  14. {.........................................................}
  15.    procedure spread (lt : LineStyle; extra, T : integer);
  16.       label 20;
  17.       begin
  18.       if (T = 0) then
  19.          begin  { only partial frame fits }
  20.          if (useXaxis) then 
  21.        diagonal (a0, b0, a1, b1, fontindex)
  22.          else 
  23.        diagonal (b0, a0, b1, a1, fontindex);
  24.          goto 20;  { exit }
  25.          end;
  26.       J := 0;
  27.       s := float (b1 - b0)/float(a1 - a0);
  28.       z := float (extra)/float(T);
  29.       case lt of
  30.          dotted : repeat a2 := a0 + J*frame;
  31.                          if (extra > 0) then a2 := a2 + round(J*z);
  32.                          a3 := a2 + dot;
  33.                          b2 := round(s*(a2-a0) + b0);
  34.                          b3 := round(s*(a3-a0) + b0);
  35.                          if (a3 <= a1) then
  36.                             begin
  37.                             if (useXaxis) then
  38.                   diagonal (a2, b2, a3, b3, fontindex)
  39.                             else  
  40.                   diagonal (b2, a2, b3, a3, fontindex);
  41.                             end;
  42.                          J := J + 1;
  43.                      until (a3 >= a1);
  44.          dashed : repeat a2 := a0 + J*frame;
  45.                          if (extra > 0) then a2 := a2 + round(J*z);
  46.                          a3 := a2 + dash;
  47.                          b2 := round(s*(a2-a0) + b0);
  48.                          b3 := round(s*(a3-a0) + b0);
  49.                          if (a3 <= a1) then
  50.                            begin
  51.                            if (useXaxis) then
  52.                  diagonal (a2, b2, a3, b3, fontindex)
  53.                            else
  54.                  diagonal (b2, a2, b3, a3, fontindex);
  55.                            end;
  56.                          J := J + 1;
  57.                      until (a3 >= a1);
  58.         dotdash : repeat a2 := a0 + J*frame;
  59.                          if (extra > 0) then a2 := a2 + round(J*z);
  60.                          a3 := a2 + dash;
  61.                          b2 := round(s*(a2-a0) + b0);
  62.                          b3 := round(s*(a3-a0) + b0);
  63.                          if (a3 <= a1) then
  64.                             begin
  65.                             if (useXaxis) then
  66.                   diagonal (a2, b2, a3, b3, fontindex)
  67.                             else
  68.                   diagonal (b2, a2, b3, a3, fontindex);
  69.                             a2 := a3 + gap;
  70.                             if (extra > 0) then a2 := a2 + round(z*0.5);
  71.                             a3 := a2 + dot;
  72.                             b2 := round(s*(a2-a0) + b0);
  73.                             b3 := round(s*(a3-a0) + b0);
  74.                             if (a3 <= a1) then
  75.                                begin
  76.                                if (useXaxis) then
  77.                      diagonal (a2, b2, a3, b3, fontindex)
  78.                                else
  79.                      diagonal (b2, a2, b3, a3, fontindex);
  80.                                end;
  81.                             end;
  82.                          J := J + 1;
  83.                      until (a3 >= a1);
  84.          end;
  85.      20:
  86.       end;   { spread }
  87.       
  88. {......................................................}               
  89.    procedure balance (lt : LineStyle; extra, T : integer);
  90.       label 30;
  91.       begin
  92.       if (T = 0) then
  93.          begin  { only partial frame fits }
  94.          if (useXaxis) then
  95.         diagonal (a0, b0, a1, b1, fontindex)
  96.          else
  97.         diagonal (b0, a0, b1, a1, fontindex);
  98.          goto 30; { exit }
  99.          end;
  100.       J := 0;
  101.       s := float(b1 - b0)/float(a1 - a0);
  102.       case lt of
  103.          dashed : repeat a2 := a0 + J*frame - extra div 2;
  104.                          a3 := a2 + dash;
  105.                          if (J = 0) then a2 := a0;
  106.                          if (a3 > a1) then a3 := a1;
  107.                          b2 := round(s*(a2-a0) + b0);
  108.                          b3 := round(s*(a3-a0) + b0);
  109.                          if (a3 <= a1) then
  110.                            begin
  111.                            if (useXaxis) then
  112.                  diagonal (a2, b2, a3, b3, fontindex)
  113.                            else
  114.                  diagonal (b2, a2, b3, a3, fontindex);
  115.                            end;
  116.                          J := J + 1;
  117.                      until (a3 >= a1);
  118.         dotdash : repeat a2 := a0 + J*frame - extra div 2;
  119.                          a3 := a2 + dash;
  120.                          if (J = 0) then a2 := a0;
  121.                          if (a3 > a1) then a3 := a1;
  122.                          b2 := round(s*(a2-a0) + b0);
  123.                          b3 := round(s*(a3-a0) + b0);
  124.                          if (a3 <= a1) then
  125.                             begin
  126.                             if (useXaxis) then
  127.                   diagonal (a2, b2, a3, b3, fontindex)
  128.                             else 
  129.                   diagonal (b2, a2, b3, a3, fontindex);
  130.                             a2 := a3 + gap;
  131.                             a3 := a2 + dot;
  132.                             b2 := round(s*(a2-a0) + b0);
  133.                             b3 := round(s*(a3-a0) + b0);
  134.                             if (a3 <= a1) then
  135.                                begin
  136.                                if (useXaxis) then
  137.                      diagonal (a2, b2, a3, b3, fontindex)
  138.                                else
  139.                      diagonal (b2, a2, b3, a3, fontindex);
  140.                                end;
  141.                             end;
  142.                          J := J + 1;
  143.                      until (a3 >= a1);
  144.          end;
  145.      30:
  146.       end;  { balance }
  147.       
  148. {......................................................}   
  149.   function project (I : integer) : integer;
  150.     var K : integer;        { gives the projection of lengths onto axes }
  151.     begin
  152.     K := round(I*float(abs(a1-a0))/s);
  153.     if K = 0 then K := 1;
  154.     project := K;
  155.     end;
  156. {......................................................}
  157.   procedure setlengths (findex :integer);
  158.         (*  sets the "optimal" sizes for textured lines *)
  159.     var penrad : integer;
  160.         siz : VThickness;
  161.     begin
  162.     penrad := VFontTable[findex]^.PenSize;
  163.     siz := VFontTable[findex]^.psize;
  164.  
  165.     Dotdot  :=  penrad div siz;   Dotgap := 6 * penrad;
  166.     Dashdash := 6 * penrad;  Dashgap := 6 * penrad;
  167.     DDotdash := 6 * penrad;  DDotgap := 4 * penrad; 
  168.     DDotdot :=  penrad div siz;
  169.     end;
  170. {........................................}
  171. procedure setframesize;
  172. begin
  173.  case line_type of        { length of frame depends on type of broken line }
  174.     solid   : frame := 0;
  175.     dotted  : frame := gap + dot;
  176.     dashed  : frame := gap + dash;
  177.     dotdash : frame := 2*gap + dot + dash;
  178.     end;
  179. end;
  180.  
  181. {.................................................}         
  182. begin  (*  TylBrokenLine *)
  183. if ((x0 = x1) and (y0 = y1)) then
  184.   begin
  185.   diagonal (x0, y0, x1, y1, fontindex); { null line }
  186.   goto 10;
  187.   end;
  188.  
  189.   setlengths (fontindex);
  190.  
  191. if (abs (y1-y0) > abs(x1-x0)) then    { longer axis is used as base }
  192.   begin
  193.   useXaxis := false;
  194.   a0 := y0;  b0 := x0;
  195.   a1 := y1;  b1 := x1;
  196.   end
  197. else
  198.   begin
  199.   useXaxis := true;
  200.   a0 := x0;  b0 := y0;
  201.   a1 := x1;  b1 := y1;
  202.   end;
  203. { the distance between a0 and a1 is now greater than that between b0 and b1. }
  204.  
  205. { redefine distances as integral units along axes }
  206.  s := distance (float(a0),float(b0),float(a1),float(b1));
  207.  
  208.  case line_type of
  209.    solid: ;
  210.    dotted:
  211.      begin
  212.      gap := project(Dotgap);
  213.      dot := project(Dotdot);
  214.      end;
  215.    dashed:
  216.      begin
  217.      gap := project(Dashgap);
  218.      dash := project(Dashdash);
  219.      end;
  220.    dotdash:
  221.      begin
  222.      gap := project(DDotgap);
  223.      dot := project(DDotdot);
  224.      dash := project(DDotdash);
  225.      end;
  226.    end;
  227.  
  228.              { ensure direction of line is from smaller to
  229.                larger along the longer axis }
  230.  if (a0 > a1) then     
  231.     begin
  232.     J := a0; a0 := a1; a1 := J;
  233.     J := b0; b0 := b1; b1 := J;
  234.     end;
  235.     
  236.  setframesize; 
  237.  
  238.  a1ma0 := a1 - a0;
  239.  
  240.     { fit is the number of frames that fit in line }
  241.  if (frame <> 0) then
  242.    begin
  243.    fit := (float(a1ma0) / float(frame));
  244.    end
  245.  else
  246.    fit := 1.0;
  247.  
  248.  if (fit >= 1.0) then
  249.    T := round (fit)
  250.  else
  251.    begin
  252.   (* change frame elements (dot, dash, gap) since frame is too large *)
  253.      case line_type of
  254.        dotted : begin
  255.                gap := gap - (frame - a1ma0);
  256.         if (gap < dot) then 
  257.           begin
  258.           goto 10; (* exit *)
  259.           end;
  260.         setframesize;
  261.         end;
  262.  
  263.     dashed,
  264.     dotdash : begin
  265.     (* idea:decrease gap; if too small then shrink dash and refigure gap*)
  266.          if ((frame - a1ma0) > (gap div 2)) then
  267.            begin
  268.            dash := round (dash * fit * 0.80);
  269.            gap := round (gap * fit);
  270.            setframesize;
  271.            end;
  272.          gap := gap - (frame - a1ma0);
  273.          if (line_type = dotdash) then
  274.            gap := gap div 2;
  275.          if (gap < dot) then 
  276.            begin
  277.            goto 10; (* exit *)
  278.            end;
  279.          setframesize;
  280.          end;
  281.     end; (* case *)
  282.      T := 1; (* NOW it will fit *)
  283.    end;  (* else *)
  284.  
  285.  
  286.  case line_type of
  287.     solid : begin
  288.           if (useXaxis) then
  289.             diagonal (a0, b0, a1, b1, fontindex)
  290.           else 
  291.                 diagonal (b0, a0, b1, a1, fontindex);
  292.         end;
  293.  
  294.     dotted : begin         { dotted lines begin and end on a dot }
  295.          if ((T*frame + dot) = a1ma0) then
  296.         spread(dotted, 0, T) 
  297.          else if ((T*frame + dot) > a1ma0) then
  298.              begin
  299. {        gap := gap - ((T*frame+dot)-a1ma0);
  300. {}
  301.             spread(dotted, a1ma0 - T*frame - dot, T);
  302.  
  303. {              spread(dotted, a1ma0 - (T-1)*frame - dot, T-1);
  304. {}
  305.         end
  306.          else 
  307.            spread(dotted, a1ma0 - T*frame - dot, T);
  308.          end;
  309.  
  310.     dashed : begin
  311.                { dashed lines begin and end on dash :
  312.             the beginning and ending dashes are at least half
  313.             the dash length long. }
  314.           if ((T*frame + dash) = a1ma0) then 
  315.         spread(dashed, 0, T)
  316.          else if ((T*frame + dash) > a1ma0) then
  317.         balance(dashed, T*frame + dash - a1ma0, T)
  318.          else spread(dashed, a1ma0 - T*frame - dash, T);
  319.          end;
  320.  
  321.     dotdash : begin        { if ending on a dash then beginning and ending
  322.             dashes are half the dash length long - final
  323.             dots are full dot length }
  324.           if ((T*frame + dash) = a1ma0) then
  325.          spread(dotdash, 0, T)
  326.           else if ((T*frame + dash + gap + dot) = a1ma0) then
  327.          spread(dotdash, 0, T)
  328.           else if ((T*frame + dash) > a1ma0) then
  329.          balance(dotdash, T*frame + dash - a1ma0, T)
  330.           else if ((T*frame + dash + gap + dot) > a1ma0) then
  331.          spread(dotdash, a1ma0 - T*frame - dash, T)
  332.           else spread(dotdash, a1ma0 - T*frame - dash - gap - dot, T);
  333.           end;
  334.     end;
  335. 10:
  336.  end;
  337.  
  338.     
  339.  
  340. {-------------------------------------------------------}
  341. procedure clampthickness (var thic : VThickness);
  342.   begin
  343.   (* #### this is just a simple clamp
  344.     really should be something like:
  345.     while not (thic in set_of_appropriate_thicknesses) do
  346.       modify thic and try again
  347.   *)
  348.   if (thic <= LoVThick ) then
  349.     thic := LoVThick + 1;
  350.   while ((not (thic in [1,2,3,4,5,6,7,8,9,10,11,12])) and
  351.       (thic <= HiVThick)) do
  352.     thic := thic + 1;
  353.   
  354.   if (thic >  HiVThick) then
  355.     thic := HiVThick;
  356.   end;
  357.   
  358. {----------------------------------------------------------}
  359. procedure slurclamp (var thic : ThickAryType; totpts : integer);
  360.   (* this post-clamps the sampled thicknesses calculated over the
  361.   whole of the spline *)
  362.   
  363.   var i : integer;
  364.    oneseventh : integer;
  365.    middle : integer;
  366.    startval, endval: integer;
  367.    deltaval, val, incrval, alpha, alphaincr: real;
  368.    
  369.   begin 
  370.   { $$ NOTE:: How does the ttspline interpolation of thicknesses
  371.   compare to the below results?? Can we avoid having it done
  372.   elsewhere and concentrate on it here?? }
  373.   
  374.   oneseventh := round (totpts / 7.0);
  375.   for i := 1 to oneseventh do
  376.     begin
  377.     thic[i] := thic[1];
  378.     end;
  379.   for i := 6*oneseventh to totpts do
  380.     begin
  381.     thic[i] := thic[totpts];
  382.     end;  
  383.   
  384.   middle := round (totpts / 2.0);
  385.   for i := 3*oneseventh to 4*oneseventh do
  386.     begin
  387.     thic[i] := thic[middle];
  388.     end;
  389.   
  390.   startval := thic[oneseventh - 1];
  391.   endval := thic[3*oneseventh + 1];
  392.   deltaval := (2*(endval - startval))/(2*oneseventh);
  393.   alphaincr := PI / (2 * oneseventh + 1);
  394.   alpha := PI;
  395.   val := float(startval);
  396.   for i := oneseventh to (3*oneseventh - 1) do
  397.     begin     (* interpolate: ease in from minthick to middlethickness *)
  398.     alpha := alpha + alphaincr;
  399.     incrval := ((cos (alpha) + 1.0) / 2.0) * deltaval;
  400.     val := val + incrval;
  401.     thic[i] := round(val);
  402.     end;
  403.   
  404.   startval := thic[4*oneseventh - 1];
  405.   endval := thic[6*oneseventh + 1];
  406.   deltaval := (2*(endval - startval))/(2*oneseventh);
  407.   alphaincr := PI / (2 * oneseventh + 1);
  408.   alpha := 0.0;
  409.   val := float(startval);
  410.   for i := (4*oneseventh + 1) to 6*oneseventh do
  411.     begin  (* ease out from middle thickness to min thick at far end *)
  412.     alpha := alpha + alphaincr;
  413.     incrval := ((cos (alpha) + 1.0) / 2.0) * deltaval;
  414.     val := val + incrval;
  415.     thic[i] := round(val);
  416.     end;
  417.   end;
  418.   
  419. {-------------------------------------------------------}
  420. procedure layline (xl, yb, xr, yt, fontindex : integer; 
  421.            pattern : LineStyle; useVecfontOnly : boolean);
  422.   var t: integer;  
  423.   begin
  424.   if (xr < xl) then
  425.     begin
  426.     t := xr; xr := xl; xl := t;
  427.     t := yb; yb := yt; yt := t;
  428.     end;
  429.   
  430.   isetfont (VFontTable[fontindex]^.DVIFontNum);
  431.   
  432.   (* we may want to require using a vector font only,
  433.   instead of a combination of vectors and TeX-rules.
  434.   It may look better this way.
  435.   *)  
  436.     if (useVecfontOnly) then
  437.        begin
  438.        tylBrokenLine (xl, yb, xr, yt, fontindex, pattern);
  439.        end
  440.     else
  441.       begin (* be smart about the lines *)
  442.       if ((xl = xr) and (yb = yt)) or
  443.       ((xl <> xr) and (yb <> yt)) then    (* Null or diagonal lines *)
  444.       begin
  445.       if (pattern = solid) then
  446.           diagonal (xl, yb, xr, yt, fontindex)
  447.       else
  448.         tylBrokenLine (xl, yb, xr, yt, fontindex, pattern);
  449.       end
  450.       else
  451.          begin
  452. {     if (pattern = solid) then
  453.        hvline (xl, yb, xr, yt, fontindex) (* make use of rules *)
  454.      else
  455. USENORULES }
  456.        tylBrokenLine (xl, yb, xr, yt, fontindex, pattern);
  457.      end
  458.       end;
  459.     
  460.   end;
  461.   
  462.   
  463.   
  464. {------------------------------------------------------}
  465. procedure layAspline (thetype : SplineKind; 
  466.               isclosed : boolean;
  467.               isanArc: boolean;
  468.               domarks : integer;
  469.               var cpts : ControlPoints;
  470.               numpts : integer;
  471.               thick: VThickness;
  472.               vkind : VectKind;
  473.               patt : LineStyle);
  474.   const DontDoThicks = false;
  475.     VectorsOnly = true;
  476.   var pointList: SplineSegments;
  477.     i, xs, ys : integer;
  478.     tt1, tt2 : ThickAryType;
  479.     F: VecIndex;
  480.   begin
  481.   
  482.   clampthickness (thick);  
  483.   for i := 0 to (numpts + 3) do
  484.     tt1[i] := thick;
  485.   
  486.   (*  do any marks if necessary to show the control points *)
  487.   if (domarks > 0) then
  488.     begin
  489.     F := GetVectFont (domarks, VKCirc);
  490.     isetfont (VFontTable[F]^.DVIFontNum);
  491.     for i := 1 to numpts do
  492.       begin
  493.       Tyldot (cpts[i,1], cpts[i,2]);
  494.       end;  
  495.     end;  
  496.   
  497.   drawSpline (thetype, isclosed, isanArc, patt,
  498.          numpts, cpts, pointList, DontDoThicks, tt1, tt2);
  499.   
  500.   
  501.   F := GetVectFont (thick, vkind);
  502.   xs := pointList[1, 1];
  503.   ys := pointList[1, 2];
  504.   
  505.   for i := 2 to lastPoint do
  506.     begin
  507.     layline (xs, ys, pointList[i, 1], pointList[i, 2], F, patt, VectorsOnly);
  508.     xs := pointList[i, 1];
  509.     ys := pointList[i, 2];
  510.     end;
  511.   if (isclosed) then (* complete the motion *)
  512.     layline (pointList[lastPoint,1], pointList[lastPoint,2],
  513.          pointList[1,1], pointList[1,2], F, patt, VectorsOnly);
  514.   end;
  515.   
  516.  
  517. {-----------------------------------------------------}
  518. procedure layNspline (thetype : SplineKind; 
  519.             isclosed : boolean;
  520.             isitaslur : boolean; 
  521.             domarks : integer;
  522.             var cpts : ControlPoints;
  523.             numpts : integer;
  524.             var thickmatrix : ThickAryType;
  525.             vkind : VectKind;
  526.             patt : LineStyle);
  527.   const NotAnArc = false;
  528.     DoThicksToo = true;
  529.     VectorsOnly = true;
  530.   var pointList: SplineSegments;
  531.     i, xs, ys : integer;
  532.     ts : VThickness;
  533.     tt : ThickAryType;
  534.     F : VecIndex;
  535.   begin
  536.   (*  do any marks if necessary to show the control points *)
  537.   if (domarks > 0) then
  538.     begin
  539.     F := GetVectFont (domarks, VKCirc);
  540.     isetfont (VFontTable[F]^.DVIFontNum);
  541.     for i := 1 to numpts do
  542.       begin
  543.       Tyldot (cpts[i,1], cpts[i,2]);
  544.       end;  
  545.     end;  
  546.   
  547.   drawSpline (thetype, isclosed, NotAnArc, patt,
  548.         numpts, cpts, pointList,
  549.         DoThicksToo, thickmatrix, tt);
  550.   if ((isitaslur) and (not skiptsclamp))  then
  551.     begin
  552.     slurclamp(tt, lastPoint);  (* which kind of clamping to use *)
  553.     end;
  554.   
  555.   xs := pointList[1, 1];
  556.   ys := pointList[1, 2];
  557.   ts := tt[1];
  558.   
  559.   for i := 2 to lastPoint do
  560.     begin
  561.     clampthickness (ts);
  562.     F := GetVectFont (ts, vkind);
  563.     layline (xs, ys, pointList[i, 1], pointList[i, 2], F, patt, VectorsOnly);
  564.     xs := pointList[i, 1];
  565.     ys := pointList[i, 2];
  566.     ts := tt[i];
  567.     end;
  568.   if (isclosed) then
  569.     begin
  570.     ts := tt[lastPoint];
  571.     clampthickness(ts);
  572.     F := GetVectFont (ts, vkind);
  573.     layline (pointList[lastPoint,1], pointList[lastPoint,2],
  574.          pointList[1,1], pointList[1,2], F, patt, VectorsOnly);
  575.     end;
  576.   end;
  577.   
  578.   
  579.   
  580. {-----------------------------------------------------}    
  581. procedure TylBeam (* fromx, fromy, tox, toy: ScaledPts;
  582.            staffsize : integer; kind : BeamKind *); 
  583.  
  584.   begin
  585.  
  586.   end; (* TylBeam *)
  587.   
  588.   
  589. {-------------------------------------------------------}
  590. procedure TylLine (* xl, yb, xr, yt: ScaledPoints;
  591.             thickness: VThickness;
  592.             vec: VectKind; patt : LineStyle *);
  593.   const dontCare = false;
  594.   var findex: VecIndex;
  595.   begin
  596.   clampthickness (thickness);
  597.   findex := GetVectFont (thickness, vec);
  598.   layline (xl, yb, xr, yt, findex, patt, dontCare);
  599.   end;
  600.   
  601.   
  602. {-----------------------------------------------------}
  603. procedure TylThickThinSpline (* thetype : SplineKind; isclosed : boolean;
  604.               var KnotArray: ControlPoints; 
  605.               var ThikThinAry: ThickAryType;
  606.               numknots: integer;
  607.               vec: VectKind;
  608.               patt : LineStyle; domarks : integer *);
  609.   const NotAnArc = false;
  610.   begin 
  611.   layNspline (thetype, isclosed, NotAnArc, domarks, KnotArray, numknots, 
  612.         ThikThinAry, vec, patt);
  613.   end;
  614.   
  615. {----------------------------------------------------}
  616. procedure TylSpline (* thetype : SplineKind; isclosed : boolean;
  617.          var KnotArray: ControlPoints; numknots: integer;
  618.          thick: VThickness; vec: VectKind; patt : LineStyle; domarks : integer*);
  619.   const NotAnArc = false;
  620.   begin
  621.    layAspline (thetype, isclosed, NotAnArc, domarks, KnotArray, numknots, 
  622.         thick, vec, patt);
  623.   end;
  624.   
  625. {-----------------------------------------------------}
  626. procedure TylTieSlur (* KnotArray: ControlPoints; 
  627.               numknots: integer;
  628.               minthick, maxthick: VThickness *);
  629.   const ItsASlur = true;
  630.       NotClosed = false;
  631.   var ourttarray : ThickAryType;
  632.     one7th : real;
  633.     val : VThickness;
  634.   begin
  635.   
  636.   clampthickness (minthick);
  637.   clampthickness (maxthick);
  638.   if (numknots <> 5) then
  639.       writeln ('TieSlur needs 5 control points ');
  640.   one7th := 1.0/7.0;
  641.   val := round (one7th * (maxthick - minthick));
  642.   ourttarray[1] := minthick;
  643.   ourttarray[2] := minthick + val;
  644.   ourttarray[3] := maxthick;
  645.   ourttarray[4] := minthick + val;    
  646.   ourttarray[5] := minthick;
  647.   
  648.   layNspline (CATROM, NotClosed, ItsASlur, 0, KnotArray, numknots, ourttarray, 
  649.           VKCirc, solid);
  650.   end;
  651.   
  652.   
  653. {-------------------------------------------------------}
  654. procedure doTylArc (* iscircle : boolean;
  655.             var apts : ControlPoints;
  656.             numknots : integer; 
  657.             thick : VThickness; 
  658.             vec : VectKind;
  659.             patt : LineStyle *);
  660.   
  661.   const ItsAnArc = true;
  662.   begin
  663.   
  664.   layAspline (BSPL, iscircle, ItsAnArc, 0, apts, numknots, thick, vec, patt);
  665.   end;
  666.   
  667. {-----------------------------------------------------------}
  668. procedure TylArc (* radius : ScaledPts; centx, centy : ScaledPts;
  669.           firstangle, secondangle : integer;
  670.           thick : VThickness; vec : VectKind; patt : LineStyle *);
  671.   var apts : ControlPoints; 
  672.     numknots : integer;
  673.     iscircle : boolean;
  674.   begin
  675.   iscircle := (firstangle = secondangle);
  676.   if iscircle then
  677.     begin
  678.   {    maxspan := round ((360.0 / 16.0) * DEGTORAD * radius);
  679.   {}
  680.     defineCircleCpts (radius, centx, centy, apts, numknots);
  681.     end
  682.   else
  683.     begin
  684.   {    maxspan := round ((abs (secondangle - firstangle) / 16.0) * DEGTORAD * radius);
  685. { }
  686.   definearcpts (radius, centx, centy, 
  687.           firstangle, secondangle, apts, numknots);
  688.   end;
  689.  
  690.   doTylArc (iscircle, apts, numknots, thick, vec, patt); 
  691.  
  692.   end;
  693.   
  694. {-----------------------------------------------------------}
  695. procedure TylLabel (* xpos, ypos : ScaledPts;
  696.           fontstyle : integer;
  697.           phrase : charstring;
  698.           phraselen : integer *); 
  699. var findex : integer;
  700.   c : integer;
  701.   spaceover : integer;
  702.   
  703. begin
  704. if ((fontstyle < 1) or (fontstyle > MAXLABELFONTS)) then
  705.   begin
  706.   complain (ERRREALBAD);
  707.   writeln(logfile,'Unexpected bad fontstyle in TylLabel: ',fontstyle:0,'?');
  708.   jumpout;
  709.   end;
  710. findex := GetLabFont (fontstyle);
  711. isetpos (xpos, ypos);
  712. IPUSH;
  713. isetfont (LFontTable[findex]^.DVIFontNum);
  714. spaceover := LFontTable[findex]^.spacewidth;
  715. for c := 1 to phraselen do
  716.   begin
  717.   if (phrase[c] <> xchr[32]) then
  718.     begin
  719.     cmd1byte (SET1);
  720.     cmd1byte (xord[ phrase[ c ]]);
  721.     end
  722.   else
  723.     begin (* move over *)
  724.     cmd1byte (RIGHTLEFT + 2); (* assume distance is less than 3 bytes *)
  725.     cmdSigned (spaceover, 3);
  726.     end;
  727.   end;
  728. IPOP;
  729. end;
  730.  
  731.   
  732. (*  && start dvidvi section *)
  733. {-----------------------------------------------------}
  734. procedure initialize;
  735.   var
  736.       i: integer;
  737.   begin
  738.       for i := 0 to 31 do 
  739.       xchr[i] := '?';
  740.       xchr[32] := ' ';
  741.       xchr[33] := '!';
  742.       xchr[34] := '"';
  743.       xchr[35] := '#';
  744.       xchr[36] := '$';
  745.       xchr[37] := '%';
  746.       xchr[38] := '&';
  747.       xchr[39] := '''';
  748.       xchr[40] := '(';
  749.       xchr[41] := ')';
  750.       xchr[42] := '*';
  751.       xchr[43] := '+';
  752.       xchr[44] := ',';
  753.       xchr[45] := '-';
  754.       xchr[46] := '.';
  755.       xchr[47] := '/';
  756.       xchr[48] := '0';
  757.       xchr[49] := '1';
  758.       xchr[50] := '2';
  759.       xchr[51] := '3';
  760.       xchr[52] := '4';
  761.       xchr[53] := '5';
  762.       xchr[54] := '6';
  763.       xchr[55] := '7';
  764.       xchr[56] := '8';
  765.       xchr[57] := '9';
  766.       xchr[58] := ':';
  767.       xchr[59] := ';';
  768.       xchr[60] := '<';
  769.       xchr[61] := '=';
  770.       xchr[62] := '>';
  771.       xchr[63] := '?';
  772.       xchr[64] := '@';
  773.       xchr[65] := 'A';
  774.       xchr[66] := 'B';
  775.       xchr[67] := 'C';
  776.       xchr[68] := 'D';
  777.       xchr[69] := 'E';
  778.       xchr[70] := 'F';
  779.       xchr[71] := 'G';
  780.       xchr[72] := 'H';
  781.       xchr[73] := 'I';
  782.       xchr[74] := 'J';
  783.       xchr[75] := 'K';
  784.       xchr[76] := 'L';
  785.       xchr[77] := 'M';
  786.       xchr[78] := 'N';
  787.       xchr[79] := 'O';
  788.       xchr[80] := 'P';
  789.       xchr[81] := 'Q';
  790.       xchr[82] := 'R';
  791.       xchr[83] := 'S';
  792.       xchr[84] := 'T';
  793.       xchr[85] := 'U';
  794.       xchr[86] := 'V';
  795.       xchr[87] := 'W';
  796.       xchr[88] := 'X';
  797.       xchr[89] := 'Y';
  798.       xchr[90] := 'Z';
  799.       xchr[91] := '[';
  800.       xchr[92] := '\';
  801.       xchr[93] := ']';
  802.       xchr[94] := '^';
  803.       xchr[95] := '_';
  804.       xchr[96] := '`';
  805.       xchr[97] := 'a';
  806.       xchr[98] := 'b';
  807.       xchr[99] := 'c';
  808.       xchr[100] := 'd';
  809.       xchr[101] := 'e';
  810.       xchr[102] := 'f';
  811.       xchr[103] := 'g';
  812.       xchr[104] := 'h';
  813.       xchr[105] := 'i';
  814.       xchr[106] := 'j';
  815.       xchr[107] := 'k';
  816.       xchr[108] := 'l';
  817.       xchr[109] := 'm';
  818.       xchr[110] := 'n';
  819.       xchr[111] := 'o';
  820.       xchr[112] := 'p';
  821.       xchr[113] := 'q';
  822.       xchr[114] := 'r';
  823.       xchr[115] := 's';
  824.       xchr[116] := 't';
  825.       xchr[117] := 'u';
  826.       xchr[118] := 'v';
  827.       xchr[119] := 'w';
  828.       xchr[120] := 'x';
  829.       xchr[121] := 'y';
  830.       xchr[122] := 'z';
  831.       xchr[123] := '{';
  832.       xchr[124] := '|';
  833.       xchr[125] := '}';
  834.       xchr[126] := '~';
  835.       for i := 127 to 255 do 
  836.       xchr[i] := '?'; 
  837.       for i := 0 to 127 do 
  838.       xord[chr(i)] := 32;
  839.       for i := 32 to 126 do 
  840.       xord[xchr[i]] := i; 
  841.       initallspline;
  842.       initVnMnLtables;
  843.       multifigure := 0;
  844.       pgfigurenum := 0;
  845.       TotBytesWritten := 0;
  846.       ourq := 0;
  847.       specstart := 0; 
  848.       currpagenum := 0;
  849.       newbackptr := (-1);
  850.       oldbackptr := (-1);
  851.       ourfontnum := (-1);  (* undefined *)
  852.       origTexfont := (-1);
  853.       ourpushdepth := 0;
  854.       FTBDs := 0;
  855.       InitDVIBuf;
  856.       nf := 0;
  857.       inpostamble := false; 
  858.       didnewfonts := false;
  859.       maxpages := 10000;
  860.       sysdependent;
  861.       s := 0;         
  862.       skiptsclamp := false;
  863.       ErrorOccurred := false;
  864.     end; 
  865.  
  866.  
  867.  
  868. procedure inputln (var buffer : strng);
  869. var
  870.     k: 0..ARRLIMIT;
  871. begin
  872.  
  873.     flush(output);
  874.  
  875.     if eoln(input) then
  876.     readln(input);
  877.     k := 1;
  878.     while (k < ARRLIMIT) and (not eoln(input)) do 
  879.       begin
  880.     buffer.str[k] := input^;
  881.     k := k + 1;
  882.     get(input)
  883.       end;
  884.     buffer.str[k] := ' ';
  885.     buffer.len := k - 1;
  886. end;
  887.  
  888. function revindex (st : strng; let : char) : integer;
  889. label 2;
  890. var posit,i : integer;
  891. begin
  892.   posit := 0;
  893.   for i := st.len downto 1 do
  894.     begin
  895.     if (st.str[i] = let) then
  896.       begin
  897.       posit := i;
  898.       goto 2;
  899.       end;  
  900.     end; 
  901. 2:
  902.    revindex := posit;
  903. end;
  904.  
  905.  
  906. procedure stripblanks (var st : strng);
  907. var i,j,k: integer;
  908.   temp : charstring;
  909.   begin
  910.   j := 1;
  911.   i := 1;
  912.   while ((i <= st.len) and 
  913.      ((st.str[i] = ' ') or (st.str[i] = xchr[HT]))) do
  914.     begin
  915.     j := j + 1;
  916.     i := i + 1;
  917.     end;
  918.  
  919. (* j now points to the first non-blank character in st.str *)
  920.   i := 1;
  921.   for k := j to st.len do
  922.     begin
  923.     if ((st.str[k] <> ' ') and (st.str[k] <> xchr[HT])) then
  924.       begin
  925.       temp[i] := st.str[k];
  926.       i := i + 1;
  927.       end;
  928.     end;
  929.    (* now copy it back *)
  930.    if (i <> 1) then
  931.      begin (* there was blankspace *)
  932.      for k := 1 to (i- 1) do
  933.        st.str[k] := temp[k];
  934.      st.len := i - 1;
  935.  
  936.      st.str[i] := chr(32); (* end of string *)
  937.  
  938.      end;
  939.   end;  
  940.  
  941.  
  942. {-----------------------------------------------------}
  943. procedure AskandOpenFiles;
  944. var isok : boolean;
  945.     i : integer;  
  946.     rp : integer;
  947.     tempname : strng;
  948. begin
  949.    isok := false;
  950.    while (not isok) do
  951.      begin
  952.      write (' DVI-input File Name: ');
  953.      inputln (dvifname);
  954.      stripblanks (dvifname);
  955.  
  956.      rp := revindex (dvifname, '.');
  957.      if (rp = 0) then
  958.        begin 
  959.        (* add a ".dvi" extension *)
  960.        i := dvifname.len;
  961.        dvifname.str[i + 1] := '.';
  962.        dvifname.str[i + 2] := 'd';
  963.        dvifname.str[i + 3] := 'v';
  964.        dvifname.str[i + 4] := 'i';
  965.        dvifname.len := i + 4;
  966.        end;
  967.      if (not opendvifile) then
  968.        begin
  969.        isok := false;  (* it is empty *)
  970.        writestrng(dvifname,false);
  971.        writeln(': Empty File??  Try another name.');
  972.        end
  973.      else
  974.        isok := true;
  975.      end;  (* while *)
  976.  
  977.         (* and ask for the name of the output file               *)
  978.     (* default it to be the same prefix, but with a ".tyl" suffix *)
  979.      strcopy (dvifname.str, outname.str, dvifname.len);
  980.      outname.len := dvifname.len;
  981.      rp := revindex (outname, '.');
  982.      i := rp - 1;
  983.      outname.str[i + 1] := '.';
  984.      outname.str[i + 2] := 't';
  985.      outname.str[i + 3] := 'y';
  986.      outname.str[i + 4] := 'l';
  987.      outname.len := i + 4;
  988.      
  989.      writeln (' DVI-output File Name :');
  990.      write('(different than input name)[default of ');
  991.      writestrng (outname,false);
  992.      write(']');
  993.      inputln (tempname);
  994.      if (tempname.len > 1) then
  995.        begin    (* a filename was typed in *)
  996.        
  997.        strcopy (tempname.str, outname.str, tempname.len);
  998.        end;
  999.  
  1000.      openoutputfile;
  1001.